functor DeadBlock (S : DEADBLOCK_STRUCTS) : DEADBLOCK =
struct
  open S
  
  
  structure Cfg = Cfg
  
  local open Cfg
  in structure Id = Id
     structure Intl = Intl
     structure T = Types
     structure B = Binop
     structure O = Operand
     structure K = Block
     structure S = Structs
     structure J = Transfer
     structure M = Stm
     structure F = Function
     structure P = Program
  end
  
  val tag = !Control.doShowOptVerbose
  fun debugPrint s =
      if tag
      then print s
      else ()
      
  fun debugPrintIds s =
      case s
       of [] => "\n"
        | x :: xs =>
          (debugPrint (Id.toString x); debugPrint " "; debugPrintIds xs)
      
  structure Set : 
  sig
    val difference : Id.t list * Id.t list -> Id.t list
    val member : Id.t list * Id.t -> bool
  end =
  struct
    fun difference (l1, l2) =
        case l1
         of [] => []
          | x :: xs =>
            if List.exists (fn y => Id.equals (x, y)) l2
            then difference (xs, l2)
            else x :: difference (xs, l2)
    
    fun member (l, x) = List.exists (fn y => Id.equals (x, y)) l
  end
  
  val {get = index, set = setIndex, destroy = destroyIndex, ...} :
      {get : Id.t -> int list, set : Id.t * int list -> unit, destroy : unit -> unit} =
      Property.destGetSet (Id.plist, Property.initConst [])
           
  fun loopDeadBlocks (names, blocks) =
      case blocks
       of [] => []
        | x :: xs => 
          let val newBlock =
                  if Set.member (names, K.name x)
                  then []
                  else [x]
          in  newBlock @ (loopDeadBlocks (names, xs))
          end
          
  fun adjustPhiSrc (deadBlockNames, src) =
      case src
        of [] => []
         | {operand, from} :: xs =>
           if Set.member (deadBlockNames, from)
           then adjustPhiSrc (deadBlockNames, xs)
           else {operand=operand, from=from} :: (adjustPhiSrc (deadBlockNames, xs))
           
        
  fun adjustPhiStms (deadBlockNames, s) =
      case s
       of [] => []
        | (M.Phi {line, dest, src}) :: xs =>
          let val newSrc = adjustPhiSrc (deadBlockNames, src)
              val newPhi = if List.length newSrc = 1
                           then M.Assign {line = line,
                                          dest = dest,
                                          src = #operand (hd newSrc),
                                          ty = T.Intt}
                           else M.Phi {line = line,
                                       dest = dest,
                                       src = newSrc}
          in  newPhi :: adjustPhiStms (deadBlockNames, xs)
          end
        | _ => s
        
  fun adjustPhiBlock (deadBlockNames, b) =
      case b
       of K.T {name,
              prop,
              stms,
              transfer,
              successors} =>
          let val new = adjustPhiStms (deadBlockNames, stms)
          in  K.T {name = name,
                   prop = prop,
                   stms = new,
                   transfer = transfer,
                   successors = successors}
          end
      
  fun adjustPhiBlocks (deadBlockNames, blocks) = 
      List.map (fn x => adjustPhiBlock (deadBlockNames, x)) blocks
  
  fun shrinkFunc f =
      case f
       of F.T {name,
               exit,
                rettype,
                args,
                locals,
                blocks,
                pre,
                post} =>
          let val {graph, getName, labelNode, ...} = F.setNameGraph f
              val reachable = F.reachable (f, name)
              val _ = debugPrint "\nthe reachable labels are: "
              val _ = debugPrintIds reachable
              val allBlockNames = List.map K.name blocks
              val deadBlockNames = Set.difference (allBlockNames, reachable)
              val _ = debugPrint "\nthe dead labels are: "
              val _ = debugPrintIds deadBlockNames
              val newBlocks = loopDeadBlocks (deadBlockNames, blocks)
              val newBlocks = adjustPhiBlocks (deadBlockNames, newBlocks)
              val new = F.T {name = name,
                             exit = exit,
                             rettype = rettype,
                             args = args,
                             locals = locals,
                             blocks = newBlocks,
                             pre = pre,
                             post = post}
              val _ = debugPrint "\noutput the graph after deadBlock\n"
              val _ = if tag
                      then F.toDot (new, "afterDeadBlock")
                      else ()
              val _ = destroyIndex ()
          in  new
          end
  
  fun shrinkProg f =
      case f
       of P.T {structs, gvars, funcs, ...} =>
          let val _ = ()
          in  P.T {structs = structs,
                   gvars = gvars,
                   funcs = List.map shrinkFunc funcs}
          end
  
  fun shrink f=
      let val _ = debugPrint "\ndead block starting\n"
          val new = shrinkProg f
          val _ = debugPrint "\ndead block finished\n"
      in  new
      end
end
